home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
TPUG - Toronto PET Users Group
/
TPUG Users Group CD
/
TPUG Users Group CD.iso
/
AMIGA
/
AMICUS
/
AMIBEST4.ADF
/
AmigaBasicStuff
/
PointerEd
/
PEditor.BAS
< prev
next >
Wrap
BASIC Source File
|
1987-07-22
|
14KB
|
664 lines
'
' Pointer Image Editor
'
' Copyright 1986 By Stephen R. Pietrowicz
'
' The author places this software in the
' public domain. Please refer to the Amazing
' Computing article accompanying this program
' for more information.
'
' Please do not remove this copyright notice.
'
DECLARE FUNCTION AllocMem&() LIBRARY
DECLARE FUNCTION FreeMem&() LIBRARY
DECLARE FUNCTION ReadPixel&() LIBRARY
LIBRARY "exec.library"
LIBRARY "intuition.library"
LIBRARY "graphics.library"
SCREEN 3,320,200,5,1
WINDOW 3,"Pointer Image Editor by SR Pietrowicz",(0,0)-(309,186),0,3
GOSUB SetUp
'
' Main loop: Wait until the mouse is clicked
' to do anything.
'
Top:
WHILE MOUSE(0) = 0:WEND
x1 = MOUSE(3):y1 = MOUSE(4)
IF (x1 > 143) THEN CheckDial
IF (y1 > 143) THEN CheckColor
x1 = INT(x1/9):y1 = INT(y1/9)
x2 = x1*9+1: y2 = y1*9+1
IF cn = 0 THEN
Ncn = 0
ELSE
Ncn = cn+5
END IF
'
' Set points in both windows, and make sure
' that the "hot spot" stays visible
'
LINE(x2,y2)-(x2+8,y2+8),Ncn,bf
PSET(180+x1,Dial+y1),Ncn
IF (PFlag = 1) AND (x1 = Psx) AND (y1 = Psy) THEN
LINE (x2+1,y2+1)-(x2+7,y2+7),11,bf
END IF
'
' Set the color that was just set in the bitmap
'
IF x1 = 0 THEN
Bit% = &H8000
ELSE
Bit% = (2^(15-x1))
END IF
Sety = Dial-2+y1
IF (cn/2 = INT(cn/2)) THEN
Sa%(Sety,0) = Sa%(Sety,0) AND NOT Bit%
ELSE
Sa%(Sety,0) = Sa%(Sety,0) OR Bit%
END IF
IF (cn < 2) THEN
Sa%(Sety,1) = Sa%(Sety,1) AND NOT Bit%
ELSE
Sa%(Sety,1) = Sa%(Sety,1) OR Bit%
END IF
WHILE MOUSE(0) <> 0:WEND
GOTO Top
'
' Move the dial, and redraw the pointer window
'
CheckDial:
IF (x1 < 152) THEN Top
IF (x1 > 163) THEN CheckRGB
MENU OFF
Dbox = Dial
DialTop:
WHILE MOUSE(0) <> 0
Dy = MOUSE(6)
IF (Dy<2) OR (Dy>141) THEN DialTop
IF (Dy = Dial) THEN DialTop
LINE (152,Dial)-(163,Dial+2),0,bf
LINE (203,Dial)-(203,Dial+15),0
Dial = Dy
LINE (152,Dial)-(163,Dial+2),1,bf
LINE (203,Dial)-(203,Dial+15),1
WEND
IF (Dbox = Dial) THEN
MENU ON
GOTO Top
END IF
'
' Redraw the pointer window
'
PointRedraw:
FOR r = 0 TO 15
By = r*9+1
Dly = Dial+r
FOR s = 0 TO 15
Bx = s*9+1
LINE(Bx,By)-(Bx+8,By+8),1,bf
LINE(Bx,By)-(Bx+8,By+8),POINT(180+s,Dly),bf
NEXT s
NEXT r
'
' Check to see if the "Hot Spot" goes in this window
'
IF LFlag = 1 THEN
RETURN
END IF
IF (Psx >= 0) THEN
IF (ABS(Dial - Psd) >= 0) AND (ABS(Dial - Psd) <= 15) THEN
Psy = Psy-(Dial-Psd)
Psd = Dial
IF (Psy >= 0) AND (Psy <= 15) THEN
NPsx = Psx*9+2
NPsy = Psy*9+2
LINE(NPsx,NPsy)-(NPsx+6,NPsy+6),11,bf
PFlag = 1
ELSE
PFlag = 0
END IF
END IF
END IF
MENU ON
GOTO Top
'
' Change the color that is being used
'
CheckColor:
IF (y1 < 150) OR (y1 > 170) THEN Top
cn = INT(x1/36)
LINE (225,Rl)-(240,Rl),0
LINE (255,Gl)-(270,Gl),0
LINE (285,Bl)-(300,Bl),0
IF cn = 0 THEN
LINE (1,176)-(143,184),0,bf
Rl = 110:Gl = 110:Bl = 110
ELSE
LINE (1,176)-(143,184),cn+5,bf
Rl = 110 - (RGB!(cn,1)*100)
Gl = 110 - (RGB!(cn,2)*100)
Bl = 110 - (RGB!(cn,3)*100)
END IF
LINE (225,Rl)-(240,Rl),11
LINE (255,Gl)-(270,Gl),11
LINE (285,Bl)-(300,Bl),11
WHILE MOUSE(0) <> 0 :WEND
GOTO Top
'
' Change the Red, Green, Blue values of the
' current color
'
CheckRGB:
IF (cn = 0) THEN Top
IF (x1 < 225) OR (x1 > 300) THEN Top
MENU OFF
IF (x1 >= 225) AND (x1 <= 240) THEN Red
IF (x1 >= 255) AND (x1 <= 270) THEN Green
IF (x1 >= 285) AND (x1 <= 300) THEN Blue
MENU OFF
GOTO Top
Red:
WHILE MOUSE(0) <> 0
Ry = MOUSE(6)
IF (Ry < 10) OR (Ry > 110) THEN Red
IF (Ry = Rl) THEN Red
LINE(225,Rl)-(240,Rl),0
Rl = Ry
LINE(225,Rl)-(240,Rl),11
RGB!(cn,1) = (110-Rl)/100
PALETTE 5+cn, RGB!(cn,1),RGB!(cn,2),RGB!(cn,3)
WEND
GOTO EndRGB
Green:
WHILE MOUSE(0) <> 0
Gy = MOUSE(6)
IF (Gy < 10) OR (Gy > 110) THEN Green
IF (Gy = Gl) THEN Green
LINE(255,Gl)-(270,Gl),0
Gl = Gy
LINE(255,Gl)-(270,Gl),11
RGB!(cn,2) = (110-Gl)/100
PALETTE 5+cn, RGB!(cn,1),RGB!(cn,2),RGB!(cn,3)
WEND
GOTO EndRGB
Blue:
WHILE MOUSE(0) <> 0
By = MOUSE(6)
IF (By < 10) OR (By > 110) THEN Blue
IF (By = Bl) THEN Blue
LINE (285,Bl)-(300,Bl),0
Bl = By
LINE (285,Bl)-(300,Bl),11
RGB!(cn,3) = (110-Bl)/100
PALETTE 5+cn, RGB!(cn,1),RGB!(cn,2),RGB!(cn,3)
WEND
EndRGB:
MENU ON
GOTO Top
'
' Initialize data structures and
' variables used by the program
'
SetUp:
TotalHeight% = 156
DIM Sa%(TotalHeight%,1)
DIM RGB!(3,3)
LFlag = 0
'
' Memory allocation has to be 4 times
' the height of the pointer image.
' The second parameter to AllocMem()
' must be 2, to allocate memory in
' the first 512K of memory.
'
MemLength% = TotalHeight% * 4
si& = AllocMem&(MemLength%,2&)
IF si& = 0 THEN
PRINT "Couldn't allocate memory"
GOTO StopIt
END IF
FOR i = 0 TO TotalHeight%
Sa%(i,0) = 0
Sa%(i,1) = 0
NEXT i
'
' Set Up Menus
'
MENU 1,0,1,"Editor"
MENU 1,1,1,"Load "
MENU 1,2,1,"Save "
MENU 1,3,1,"Clear "
MENU 1,4,1,"Quit "
MENU 2,0,1,"Pointer "
MENU 2,1,1,"Test "
MENU 2,2,1,"Reset "
MENU 2,3,1,"Hot Spot"
MENU 3,0,1,""
MENU 4,0,1,""
PALETTE 30,1,0,0
Psx = 0:Psy = 0:Psd = 2:PFlag = 1
LINE (2,2)-(8,8),11,bf
ON MENU GOSUB CheckMenu
MENU ON
'
' Pointer drawing box and gadget
'
LINE (0,0)-(145,145),1,b
LINE (150,0)-(165,145),1,b
Dial = 2
LINE (152,Dial)-(163,Dial+2),1,bf
'
' Palette that shows how "real" pointer looks
'
LINE (175,0)-(201,158),1,b
LINE (203,Dial)-(203,Dial+15),1
'
' Draw RGB Settings
'
PALETTE 12,1,0,0
PALETTE 13,0,1,0
PALETTE 14,0,0,1
LINE (220,0)-(305,158),1,b
LINE (223,9)-(242,111),1,b
LINE (253,9)-(272,111),1,b
LINE (283,9)-(302,111),1,b
LINE (225,110)-(240,110),11
LINE (255,110)-(270,110),11
LINE (285,110)-(300,110),11
Rl = 110:Gl = 110:Bl = 110
LINE (223,113)-(242,123),12,bf
LINE (253,113)-(272,123),13,bf
LINE (283,113)-(302,123),14,bf
LOCATE 18,32
PRINT "RGB"
LOCATE 19,30
PRINT "Settings"
'
' Color Box
'
PALETTE 6,1,0,0
PALETTE 7,0,1,0
PALETTE 8,0,0,1
RGB!(1,1) = 1:RGB!(1,2) = 0:RGB!(1,3) = 0
RGB!(2,1) = 0:RGB!(2,2) = 1:RGB!(2,3) = 0
RGB!(3,1) = 0:RGB!(3,2) = 0:RGB!(3,3) = 1
LINE (0,150)-(36,170),1,b
FOR i = 1 TO 3
LINE (i*36,150)-((i+1)*36,170),5+i,bf
NEXT i
LINE (0,175)-(144,185),1,b
'
' Change the system pointer to the
' default program pointer
'
DefaultPointer:
RESTORE
'
' Default program pointer data
'
DATA 14
DATA -1024,0,30720,-32768,12288,-16384
DATA 6144,-8192,3072,-4096,1536,-10240
DATA 768,-29696,384,1536,192,768
DATA 96,384,48,192,24,96
DATA 12,48,4,24,0,8
rp& = WINDOW(7)
READ Ap%
POKEW si&,0
POKEW si&+2,0
Padd = 4
FOR i = 1 TO (Ap%+1)*2
READ p1%
POKEW si&+Padd, p1%
Padd = Padd + 2
NEXT i
POKEW si&+Padd, 0
POKEW si&+Padd+2 ,0
PALETTE 17,1,0,0
PALETTE 18,.6,0,0
PALETTE 19,0,.6,.8
HotX% = 0
HotY% = 0
CALL SetPointer(rp&, si&, Ap%+1,16,HotX%,HotY%)
RETURN
'
' Menu functions
'
CheckMenu:
id = MENU(0)
item = MENU(1)
MENU OFF
'
' Editor
'
IF id = 1 THEN
'
' Load pointer from a file
'
IF item = 1 THEN
FileName$ = ""
GOSUB GetFileName
IF FileName$ = "" THEN LoadDone
GOSUB ClearImage
OPEN FileName$ FOR INPUT AS #1
INPUT #1,RGB!(1,1),RGB!(1,2),RGB!(1,3)
INPUT #1,RGB!(2,1),RGB!(2,2),RGB!(2,3)
INPUT #1,RGB!(3,1),RGB!(3,2),RGB!(3,3)
INPUT #1,Ap%
FOR j = 0 TO Ap%
INPUT #1,Sa%(j,0),Sa%(j,1)
NEXT j
INPUT #1,Psx, Psy
CLOSE #1
Psx = -Psx
Psy = -Psy
Psd = INT(Psy/16)*16+2
Psy = Psy-Psd+2
PALETTE 6,RGB!(1,1),RGB!(1,2),RGB!(1,3)
PALETTE 7,RGB!(2,1),RGB!(2,2),RGB!(2,3)
PALETTE 8,RGB!(3,1),RGB!(3,2),RGB!(3,3)
IF (Psd+Psy <= 15) THEN
PFlag = 1
ELSE
PFlag = 0
END IF
'
' Reconstruct the colors, and draw them in the palette
'
FOR Scan = 0 TO Ap%
Bit% = &H8000
Bit0% = (Sa%(Scan,0) AND &H8000)/&H8000
Bit1% = (Sa%(Scan,1) AND &H8000)/&H8000
cn = (Bit1%*2) OR Bit0%
IF cn = 0 THEN
Ncn = 0
ELSE
Ncn = cn+5
END IF
PSET(180,Scan+2),Ncn
FOR j = 14 TO 0 STEP -1
Bit% = (2^j)
Bit0% = (Sa%(Scan,0) AND Bit%)/Bit%
Bit1% = (Sa%(Scan,1) AND Bit%)/Bit%
cn = (Bit1%*2) OR Bit0%
IF cn = 0 THEN
Ncn = 0
ELSE
Ncn = cn+5
END IF
PSET(195-j,Scan+2),1
PSET(195-j,Scan+2),Ncn
NEXT j
NEXT Scan
'
' Recontruct the main drawing area
' and reset the intuition pointer
'
LFlag = 1
GOSUB PointRedraw
IF (PFlag = 1) THEN
LINE (Psx*9+2,Psy*9+2)-(Psx*9+8,Psy*9+8),11,bf
END IF
LFlag = 0
LoadDone:
MENU ON
RETURN
END IF
'
' Save current pointer to a file
'
IF item = 2 THEN
'
' Make sure there is a pointer to save...
'
Ap% = 156
PSFlag = 1
WHILE (PSFlag = 1)
IF (Ap% < 0) THEN
PSFlag = 0
ELSEIF (Sa%(Ap%,0) <> 0) OR (Sa%(Ap%,1) <> 0) THEN
PSFlag = 0
ELSE
Ap% = Ap% - 1
END IF
WEND
IF (Ap% < 0) THEN
LOCATE 21,20
PRINT "No pointer! Hit ESC "
GOTO SaveBad
END IF
FileName$ = ""
GOSUB GetFileName
IF FileName$ = "" THEN SaveDone
OPEN FileName$ FOR OUTPUT AS #1
WRITE #1,RGB!(1,1),RGB!(1,2),RGB!(1,3)
WRITE #1,RGB!(2,1),RGB!(2,2),RGB!(2,3)
WRITE #1,RGB!(3,1),RGB!(3,2),RGB!(3,3)
WRITE #1,Ap%
FOR j = 0 TO Ap%
WRITE #1,Sa%(j,0),Sa%(j,1)
NEXT j
WRITE #1,-Psx, -(Psy+Psd-2)
CLOSE #1
GOTO SaveDone
SaveBad:
Key$ = INKEY$: IF Key$ = "" THEN SaveBad
IF ASC(Key$) <> 27 THEN SaveBad
LOCATE 21,20
PRINT " "
SaveDone:
MENU ON
RETURN
END IF
'
' Clear current pointer bitmap and drawing areas
'
IF item = 3 THEN
ClearImage:
FOR i = 0 TO 156
Sa%(i,0) = 0
Sa%(i,1) = 0
NEXT i
LINE (1,1)-(144,144),0,bf
LINE (152,Dial)-(163,Dial+2),0,bf
LINE (152,2)-(163,4),1,bf
LINE (203,Dial)-(203,Dial+15),0
Dial = 2
LINE (176,1)-(200,157),0,bf
LINE (203,2)-(203,17),1
Psx = 0:Psy = 0:Psd = 2:PFlag = 1
LINE (2,2)-(8,8),11,bf
MENU ON
RETURN
END IF
'
' Quit
'
IF item = 4 THEN
GOTO StopIt
END IF
END IF
'
' Pointer functions
'
IF id = 2 THEN
'
' Use the current pointer image
'
IF item = 1 THEN
GOSUB SetIt
MENU ON
RETURN
END IF
'
' Reset the pointer in use to the default pointer
'
IF item = 2 THEN
GOSUB DefaultPointer
MENU ON
RETURN
END IF
'
' Set the pointer's "Hot Spot"
'
IF item = 3 THEN
PickSet:
WHILE MOUSE(0) = 0:WEND
x1 = MOUSE(3):y1 = MOUSE(4)
IF x1>143 OR y1>143 THEN PickSet
x1 = INT(x1/9):y1 = INT(y1/9)
x2 = x1*9+2: y2 = y1*9+2
IF (PFlag = 1) THEN
NPsx = Psx*9+2
NPsy = Psy*9+2
Pc = POINT(NPsx-1,NPsy-1)
IF (Pc <> 0) THEN
LINE(NPsx,NPsy)-(NPsx+6,NPsy+6),Pc,bf
ELSE
LINE(NPsx,NPsy)-(NPsx+6,NPsy+6),0,bf
END IF
END IF
LINE(x2,y2)-(x2+6,y2+6),11,bf
Psx = x1
Psy = y1
Psd = Dial
PFlag = 1
WHILE MOUSE(0) <> 0:WEND
ON MENU GOSUB CheckMenu
MENU ON
RETURN
END IF
END IF
RETURN
END
'
' Subroutine to return FileName$
' FileName$ is limited to 17 characters
' Hitting the escape key exits with a
' NULL value
'
GetFileName:
LOCATE 21,20
PRINT "Input file Name:"
LINE(150,173)-(300,185),1,b
Key$ = INKEY$
WHILE Key$<>"":Key$ = INKEY$:WEND
Box = 152
LINE(Box,175)-(Box+7,183),30,bf
Cursor = 20
LOCATE 23,Cursor
NameTop:
Key$ = INKEY$:IF Key$ = "" THEN NameTop
NameLen = LEN(FileName$)
IF (ASC(Key$) = 27) THEN
FileName$ = ""
GOTO NameDone
END IF
IF (ASC(Key$) = 13) AND (NameLen <>0) THEN NameDone
IF (ASC(Key$) = 8) AND (NameLen > 0) THEN
FileName$ = LEFT$(FileName$,NameLen-1)
LINE (Box,175)-(Box+7,183),0,bf
Box = Box-8
LINE (Box,175)-(Box+7,183),30,bf
GOTO NameTop
END IF
IF (NameLen >= 17) THEN NameTop
IF ((Key$ >= "0") AND (Key$ <= "9")) THEN NameAdd
IF ((Key$ >= "A") AND (Key$ <= "Z")) THEN NameAdd
IF ((Key$ >= "a") AND (Key$ <= "z")) THEN NameAdd
GOTO NameTop
NameAdd:
FileName$ = FileName$ + Key$
LINE (Box,175)-(Box+7,183),0,bf
LOCATE 23,20+NameLen
PRINT Key$;
Box = Box+8
LINE (Box,175)-(Box+7,183),30,bf
GOTO NameTop
NameDone:
LOCATE 21,20
PRINT " "
LINE(150,173)-(300,185),0,bf
RETURN
END
'
' User the pointer image on the palette as
' the default pointer
'
SetIt:
Ap% = 156
PSFlag = 1
WHILE (PSFlag = 1)
IF (Ap% < 0) THEN
PSFlag = 0
ELSEIF (Sa%(Ap%,0) <> 0) OR (Sa%(Ap%,1) <> 0) THEN
PSFlag = 0
ELSE
Ap% = Ap% - 1
END IF
WEND
IF (Ap% < 0) THEN
RETURN
END IF
POKEW si&, 0
POKEW si&+2, 0
Padd = 4
FOR j = 0 TO Ap%+1
POKEW (si&+Padd), Sa%(j,0)
Padd = Padd + 2
POKEW (si&+Padd), Sa%(j,1)
Padd = Padd + 2
NEXT j
POKEW si&+Padd, 0
POKEW si&+Padd+2 ,0
PALETTE 17,RGB!(1,1),RGB!(1,2),RGB!(1,3)
PALETTE 18,RGB!(2,1),RGB!(2,2),RGB!(2,3)
PALETTE 19,RGB!(3,1),RGB!(3,2),RGB!(3,3)
Spx% = -Psx: Spy% = -(Psy+Psd-2)
CALL SetPointer(rp&, si&, Ap%+2,16,Spx%,Spy%)
RETURN
'
' Clean up the loose ends, and exit
'
StopIt:
WINDOW CLOSE 3
SCREEN CLOSE 3
CALL FreeMem(si&,MemLength%)
LIBRARY CLOSE
END